home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istlx / ISTLX.MAC.f next >
Encoding:
Text File  |  1989-03-04  |  11.9 KB  |  350 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C
  5. C  ISTLX  - FORTRAN 77 SCANNER
  6. C           TABLES MECHANICALLY GENERATED BY FSCAN
  7. C
  8. C  VERSION 2: This version uses the revised token/comment stream
  9. C             formats and the general purpose interface to the
  10. C             scanner routine ZSCAN. Note that there is no longer
  11. C             an error file and that the list file is optional
  12. C             (a file name of '-' will prevent the list file being
  13. C             produced).
  14. C
  15.       PROGRAM ISTLX
  16.  
  17.       INTEGER SRC, TKN, LST, CMT, STATUS, MULTI
  18.       INTEGER SRCPTH(81), LSTPTH(81)
  19.       INTEGER OPEN, CREATE, GETARG
  20.  
  21.       COMMON /NAMES/  TKNPTH, CMTPTH, TPT1, TPT2, TPT3, CPT1, CPT2, CPT3
  22.       INTEGER         TKNPTH(81),CMTPTH(81)
  23.       INTEGER         TPT1, TPT2, CPT1, CPT2, TPT3, CPT3
  24.  
  25.       SAVE
  26.  
  27. C INITIALISE TIE
  28.       CALL ZINIT
  29.  
  30. C CHECK FOR THE EXISTENCE OF THE REQUIRED PATHNAMES
  31.       IF(GETARG(1, SRCPTH, 81) .EQ. -100) CALL FNAMES(1, SRCPTH)
  32.       IF(GETARG(2, LSTPTH, 81) .EQ. -100) CALL FNAMES(2, LSTPTH)
  33.       IF(GETARG(3, TKNPTH, 81) .EQ. -100) CALL FNAMES(3, TKNPTH)
  34.       IF(GETARG(4, CMTPTH, 81) .EQ. -100) CALL FNAMES(4, CMTPTH)
  35.  
  36. C FIND OUT IF FILE SPLITTING IS REQUESTED
  37.       CALL CHKNAM(MULTI)
  38.  
  39. C OPEN OR CREATE ALL FILES
  40.       SRC = OPEN (SRCPTH, 0)
  41.       IF (SRC .EQ. -1) CALL ERROR
  42.      +  ('ISTLX - UNABLE TO OPEN SOURCE FILE.')
  43.       TKN = CREATE (TKNPTH, 1)
  44.       IF (TKN .EQ. -1) CALL ERROR
  45.      +  ('ISTLX - UNABLE TO CREATE TOKEN FILE.')
  46.       CMT = CREATE (CMTPTH, 1)
  47.       IF (CMT .EQ. -1) CALL ERROR
  48.      +  ('ISTLX - UNABLE TO CREATE COMMENT FILE.')
  49.  
  50.       IF(LSTPTH(1) .NE. 45) THEN
  51.         LST = CREATE (LSTPTH, 1)
  52.         IF (LST .EQ. -1) CALL ERROR
  53.      +    ('ISTLX - UNABLE TO CREATE LIST FILE.')
  54.       ELSE
  55.         LST = -1
  56.       ENDIF
  57.  
  58. C  CALL THE SCANNING ROUTINE
  59.       CALL NEWLX (SRC, LST, TKN, CMT, STATUS, MULTI)
  60.  
  61. C  REPORT THE NUMBER OF FILES CREATED (IF MULTIPLE FILES REQUIRED)
  62.       IF(MULTI .GT. 0) THEN
  63.         CALL ZCHOUT('[ISTLX: .', 1)
  64.         CALL ZPTINT(MULTI, 1, 1)
  65.         CALL ZMESS(' Files Created].', 1)
  66.       ENDIF
  67.  
  68. C  CHECK IF ANY ERRORS WERE REPORTED AND TERMINATE THE TOOL
  69.       IF(STATUS .EQ. -2) THEN
  70.          CALL ZMESS('[ISTLX Normal Termination].', 1)
  71.          CALL ZQUIT(-2)
  72.       ELSE IF(STATUS .EQ. -1002) THEN
  73.          CALL ZMESS('[ISTLX Warnings Reported].', 1)
  74.          CALL ZQUIT(-1002)
  75.       ELSE
  76.          CALL ZMESS('[ISTLX Errors Reported].', 1)
  77.          CALL ZQUIT(-1)
  78.       ENDIF
  79.  
  80.       END
  81. C-------------------------------------------------
  82. C
  83. C  PROMPT FOR MISSING FILE NAMES
  84. C
  85.       SUBROUTINE FNAMES(OPT, PATH)
  86.  
  87.       INTEGER PATH(*), MSGS(15, 4)
  88.       INTEGER ZGTCMD
  89.       INTEGER STAT, OPT, I
  90.  
  91.       DATA (MSGS(I, 1),I=1,15)/83,111,117,114,99,101,32,
  92.      +                    32, 102,105,108,101,58,32,129/
  93.       DATA (MSGS(I, 2),I=1,15)/76,105,115,116,32,32,32,
  94.      +                    32, 102,105,108,101,58,32,129/
  95.       DATA (MSGS(I, 3),I=1,15)/84,111,107,101,110,32,32,
  96.      +                    32, 102,105,108,101,58,32,129/
  97.       DATA (MSGS(I, 4),I=1,15)/67,111,109,109,101,110,116,
  98.      +                    32, 102,105,108,101,58,32,129/
  99.  
  100.       IF(OPT .LE. 0  .OR.  OPT .GT. 4) RETURN
  101.       CALL ZPRMPT(MSGS(1, OPT))
  102.       STAT = ZGTCMD(PATH, 0)
  103.  
  104.       END
  105. C-------------------------------------------------
  106. C
  107. C  CHECK TO SEE IF MULTIPLE OUTPUT FILES ARE REQUESTED
  108. C
  109.       SUBROUTINE CHKNAM(MULTI)
  110.  
  111.       COMMON /NAMES/  TKNPTH, CMTPTH, TPT1, TPT2, TPT3, CPT1, CPT2, CPT3
  112.       INTEGER         TKNPTH(81), CMTPTH(81),
  113.      +                 TPT1, TPT2, CPT1, CPT2, TPT3, CPT3
  114.       INTEGER MULTI
  115.       INTEGER TEMP(81), POINTT, POINTC, LENGTH, I
  116. C*********************************************************************
  117. C  INSTALLER: THE FOLLOWING PARAMETERS CONTROL WHICH CHARACTERS IN A
  118. C             HOST FILENAME ARE CHANGED WHEN MULTIPLE OUTPUT FILES
  119. C             ARE REQUESTED. AS CURRENTLY SET, THE SECOND, THIRD AND
  120. C             FOURTH CHARACTERS WILL BE MODIFIED, E.G."FRED.TKN" WOULD
  121. C             BECOME "FAAA.TKN", "FAAB.TKN" ETC.
  122. C
  123.       INTEGER HOST1, HOST2, HOST3
  124.       PARAMETER (HOST1=2, HOST2=3, HOST3=4)
  125. C*********************************************************************
  126.       SAVE
  127.  
  128.       IF(TKNPTH(1) .NE. 40) THEN
  129.         IF(CMTPTH(1) .EQ. 40)
  130.      +    CALL ERROR('[ISTLX - INVALID COMMENT FILE (1)].')
  131.         MULTI = -1
  132.  
  133.       ELSE
  134.         IF(CMTPTH(1) .NE. 40)
  135.      +    CALL ERROR('[ISTLX - INVALID COMMENT FILE (2)].')
  136.  
  137.         CALL SCOPY(TKNPTH, 2, TEMP, 1)
  138.         POINTT = LENGTH(TEMP)
  139.         IF(TEMP(POINTT) .NE. 41)
  140.      +    CALL ERROR('[ISTLX - INVALID TOKEN FILE (1)].')
  141.         TEMP(POINTT) = 129
  142.         CALL SCOPY(TEMP, 1, TKNPTH, 1)
  143.  
  144.         CALL SCOPY(CMTPTH, 2, TEMP, 1)
  145.         POINTC = LENGTH(TEMP)
  146.         IF(TEMP(POINTC) .NE. 41)
  147.      +    CALL ERROR('[ISTLX - INVALID COMMENT FILE (3)].')
  148.         TEMP(POINTC) = 129
  149.         CALL SCOPY(TEMP, 1, CMTPTH, 1)
  150.  
  151.         IF(TKNPTH(1) .EQ. 35) THEN
  152.           IF(POINTT .LE. 5)
  153.      +       CALL ERROR('[ISTLX - INVALID TOKEN FILE (4)].')
  154.           TPT1 = HOST1+1
  155.           TPT2 = HOST2+1
  156.           TPT3 = HOST3+1
  157.         ELSE
  158.           DO 10 I = LENGTH(TKNPTH), 1, -1
  159.            IF(TKNPTH(I) .EQ. 47) GO TO 15
  160.    10     CONTINUE
  161.           I = 1
  162.    15     CONTINUE
  163.           IF(POINTT-I .LT. 4)
  164.      +    CALL ERROR('[ISTLX - INVALID TOKEN FILE (5)].')
  165.           TPT1 = I + 1
  166.           TPT2 = I + 2
  167.           TPT3 = I + 3
  168.         ENDIF
  169.         IF(LENGTH(TKNPTH) .LT. TPT3)
  170.      +    CALL ERROR('[ISTLX - INVALID TOKEN FILE (2)].')
  171.  
  172.         IF(CMTPTH(1) .EQ. 35) THEN
  173.           IF(POINTC .LE. 5)
  174.      +       CALL ERROR('[ISTLX - INVALID COMMENT FILE (4)].')
  175.           CPT1 = HOST1+1
  176.           CPT2 = HOST2+1
  177.           CPT3 = HOST3+1
  178.         ELSE
  179.           DO 20 I = LENGTH(CMTPTH), 1, -1
  180.             IF(CMTPTH(I) .EQ. 47) GO TO 25
  181.    20     CONTINUE
  182.           I = 1
  183.    25     CONTINUE
  184.           IF(POINTC-I .LT. 4)
  185.      +    CALL ERROR('[ISTLX - INVALID COMMENT FILE (5)].')
  186.           CPT1 = I + 1
  187.           CPT2 = I + 2
  188.           CPT3 = I + 3
  189.         ENDIF
  190.         IF(LENGTH(CMTPTH) .LT. CPT3)
  191.      +    CALL ERROR('[ISTLX - INVALID COMMENT FILE (4)].')
  192.  
  193.         TKNPTH(TPT1) = 65
  194.         TKNPTH(TPT2) = 65
  195.         TKNPTH(TPT3) = 65
  196.         CMTPTH(CPT1) = 65
  197.         CMTPTH(CPT2) = 65
  198.         CMTPTH(CPT3) = 65
  199.         MULTI = 0
  200.       ENDIF
  201.  
  202.       END
  203. C-------------------------------------------------
  204. C
  205. C  FORTRAN 77 SCANNER MAIN CONTROL SUBROUTINE
  206. C
  207. C  Repeatedly call the scanning utility and writing out
  208. C  the tokens until the end of the file. This routine is
  209. C  also responsible for creating the token stream files and
  210. C  putting the head/tail on the listing file.
  211. C
  212.       SUBROUTINE NEWLX (SRC, LST, TKN, CMT, STATUS, MULTI)
  213.  
  214. C
  215. C---------------------------------------------------------
  216. C    TOOLPACK/1    Release: 2.5
  217. C---------------------------------------------------------
  218. C
  219. C  TKLAST = LAST TOKEN NUMBER
  220. C
  221.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  222.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  223.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  224.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  225.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  226.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  227.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  228.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  229.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  230.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  231.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  232.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  233.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  234.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  235.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  236.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  237.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  238.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  239.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  240.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  241.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  242.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  243.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  244.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  245.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  246.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  247.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  248.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  249.  
  250.  
  251.       COMMON /NAMES/  TKNPTH, CMTPTH, TPT1, TPT2, TPT3, CPT1, CPT2, CPT3
  252.       INTEGER         TKNPTH(81), CMTPTH(81), TPT1,
  253.      +                TPT2, CPT1, CPT2, TPT3, CPT3
  254.  
  255.       INTEGER         SRC,LST,TKN,CMT,ERR, JUNK, I, STATUS, TKNTYP,
  256.      +                MULTI, ITKNCH, TKNCHR(1322), DESC, DESC2,
  257.      +                ZTKGTI, ZTKPTI
  258.       LOGICAL         FIRST, WASEND
  259.       INTEGER         STAT
  260.       INTEGER         CREATE
  261.  
  262.       SAVE /NAMES/
  263. C
  264.       IF(LST .NE. -1) THEN
  265.         CALL ZMESS('    TOOLPACK FORTRAN 77 SCANNER - RELEASE 2.', LST)
  266.         CALL PUTCH(10, LST)
  267.         IF(MULTI .GE. 0) THEN
  268.           CALL ZCHOUT('----   TOKEN FILE: .', LST)
  269.           CALL ZPTMES(TKNPTH, LST)
  270.           CALL ZCHOUT('     COMMENT FILE: .', LST)
  271.           CALL ZPTMES(CMTPTH, LST)
  272.         ENDIF
  273.       ENDIF
  274. C
  275. C  LOOP AROUND CALLING THE SCANNER FOR EACH TOKEN AND THEN PUTTING THE
  276. C  TOKEN IN THE TOKEN STREAM FILE, NOTE THAT COMMENTS ARE STORED AWAY
  277. C  BY GETBUF AS PART OF THE SCANNING PROCESS.
  278. C
  279.       DESC  = ZTKGTI(0, SRC, LST)
  280.       DESC2 = ZTKPTI(1, TKN, CMT)
  281.  
  282.    10 CONTINUE
  283.         CALL ZSCAN(TKNTYP, ITKNCH, TKNCHR, DESC, STATUS)
  284.         IF(STATUS .EQ. -1) RETURN
  285.         CALL ZPUTTK(TKNTYP, ITKNCH, TKNCHR, DESC2)
  286.  
  287.         IF(TKNTYP .NE. TZEOF) THEN
  288.           FIRST = .FALSE.
  289.           IF(MULTI .LT. 0) GO TO 10
  290.           IF(TKNTYP .EQ. TEND) THEN
  291.             WASEND = .TRUE.
  292.             GO TO 10
  293.           ELSE IF(TKNTYP .EQ. TZEOS) THEN
  294.             IF(.NOT. WASEND) GO TO 10
  295.           ELSE
  296.             WASEND = .FALSE.
  297.             GO TO 10
  298.           ENDIF
  299.  
  300.           WASEND = .FALSE.
  301.           FIRST = .TRUE.
  302.           MULTI = MULTI + 1
  303.           IF((TKNPTH(TPT3) .EQ. 90) .OR. (TKNPTH(TPT3) .EQ. 122)) THEN
  304.             TKNPTH(TPT3) = 65
  305.             CMTPTH(CPT3) = 65
  306.             IF((TKNPTH(TPT2) .EQ. 90) .OR. (TKNPTH(TPT2) .EQ. 122)) THEN
  307.               TKNPTH(TPT2) = 65
  308.               CMTPTH(CPT2) = 65
  309.               TKNPTH(TPT1) = TKNPTH(TPT1) + 1
  310.               CMTPTH(CPT1) = CMTPTH(CPT1) + 1
  311.             ELSE
  312.               TKNPTH(TPT2) = TKNPTH(TPT2) + 1
  313.               CMTPTH(CPT2) = CMTPTH(CPT2) + 1
  314.             ENDIF
  315.           ELSE
  316.             TKNPTH(TPT3) = TKNPTH(TPT3) + 1
  317.             CMTPTH(CPT3) = CMTPTH(CPT3) + 1
  318.           ENDIF
  319.           CALL ZPUTTK(TZEOF, 0, TKNCHR, DESC2)
  320.           CALL CLOSE(TKN)
  321.           CALL CLOSE(CMT)
  322.           TKN = CREATE(TKNPTH, 1)
  323.           CMT = CREATE(CMTPTH, 1)
  324.           IF(TKN .EQ. -1)
  325.      +      CALL ERROR('ISTLX - UNABLE TO CREATE TOKEN FILE (2).')
  326.           IF(CMT .EQ. -1)
  327.      +      CALL ERROR('ISTLX - UNABLE TO CREATE COMMENT FILE (2).')
  328.           IF(LST .NE. -1) THEN
  329.             CALL ZCHOUT('----   TOKEN FILE: .', LST)
  330.             CALL ZPTMES(TKNPTH, LST)
  331.             CALL ZCHOUT('     COMMENT FILE: .', LST)
  332.             CALL ZPTMES(CMTPTH, LST)
  333.           ENDIF
  334.           GO TO 10
  335.         ENDIF
  336.  
  337.       CALL CLOSE(TKN)
  338.       CALL CLOSE(CMT)
  339.       IF((MULTI .GT. 0) .AND. FIRST) THEN
  340.         CALL ZCHOUT('REMOVING TOKEN FILE: .', LST)
  341.         CALL ZPTMES(TKNPTH, LST)
  342.         CALL ZCHOUT('REMOVING COMMENT FILE: .', LST)
  343.         CALL ZPTMES(CMTPTH, LST)
  344.         CALL REMOVE(TKNPTH)
  345.         CALL REMOVE(CMTPTH)
  346.       ENDIF
  347.       IF(LST .NE. -1)CALL PUTCH(10, LST)
  348.  
  349.       END
  350.